home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / psxtime.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  156 lines
  1. ;;;; "psxtime.scm" Posix time conversion routines
  2. ;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; No, it doesn't do leap seconds.
  21.  
  22. (define time:days/month
  23.   '#(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years.
  24.      #(31 29 31 30 31 30 31 31 30 31 30 31)))
  25. (define (leap-year? year)
  26.   (and (zero? (remainder year 4))
  27.        (or (not (zero? (remainder year 100)))
  28.        (zero? (remainder year 400))))) ; Leap years.
  29.  
  30. ;;; Returns the `struct tm' representation of T,
  31. ;;; offset TM_GMTOFF seconds east of UCT.
  32. (define (time:split t tm_isdst tm_gmtoff tm_zone)
  33.   (set! t (difftime t tm_gmtoff))
  34.   (let* ((secs (modulo t 86400))    ; SECS/DAY
  35.      (days (+ (quotient t 86400)    ; SECS/DAY
  36.           (if (and (negative? t) (positive? secs)) -1 0))))
  37.     (let ((tm_hour (quotient secs 3600))
  38.       (secs (remainder secs 3600))
  39.       (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday.
  40.       (let loop ((tm_year 1970)
  41.          (tm_yday days))
  42.     (let ((diy (if (leap-year? tm_year) 366 365)))
  43.       (cond
  44.        ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy)))
  45.        ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy)))
  46.        (else
  47.         (let* ((mv (vector-ref time:days/month (- diy 365))))
  48.           (do ((tm_mon 0 (+ 1 tm_mon))
  49.            (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon))))
  50.           ((< tm_mday (vector-ref mv tm_mon))
  51.            (vector
  52.             (remainder secs 60) ; Seconds.    [0-61] (2 leap seconds)
  53.             (quotient secs 60)    ; Minutes.    [0-59]
  54.             tm_hour        ; Hours.    [0-23]
  55.             (+ tm_mday 1)    ; Day.        [1-31]
  56.             tm_mon        ; Month.    [0-11]
  57.             (- tm_year 1900)    ; Year    - 1900.
  58.             tm_wday        ; Day of week.    [0-6]
  59.             tm_yday        ; Days in year. [0-365]
  60.             tm_isdst        ; DST.        [-1/0/1]
  61.             tm_gmtoff        ; Seconds west of UTC.
  62.             tm_zone        ; Timezone abbreviation.
  63.             )))))))))))
  64.  
  65. (define (time:gmtime t)
  66.   (time:split t 0 0 "GMT"))
  67.  
  68. (define (time:localtime caltime . tz)
  69.   (require 'time-zone)
  70.   (set! tz (if (null? tz) (tzset) (car tz)))
  71.   (apply time:split caltime (tz:params caltime tz)))
  72.  
  73. (define time:year-70
  74.   (let* ((t (current-time)))
  75.     (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800))))
  76.  
  77. (define (time:invert decoder target)
  78.   (let* ((times '#(1 60 3600 86400 2678400 32140800))
  79.      (trough            ; rough time for target
  80.       (do ((i 5 (+ i -1))
  81.            (trough time:year-70
  82.                (offset-time trough (* (vector-ref target i)
  83.                           (vector-ref times i)))))
  84.           ((negative? i) trough))))
  85. ;;;    (print 'trough trough 'target target)
  86.     (let loop ((guess trough)
  87.            (j 0)
  88.            (guess-tm (decoder trough)))
  89. ;;;      (print 'guess guess 'guess-tm guess-tm)
  90.       (do ((i 5 (+ i -1))
  91.        (rough time:year-70
  92.           (offset-time rough (* (vector-ref guess-tm i)
  93.                     (vector-ref times i))))
  94.        (sign (let ((d (- (vector-ref target 5)
  95.                  (vector-ref guess-tm 5))))
  96.            (and (not (zero? d)) d))
  97.          (or sign
  98.              (let ((d (- (vector-ref target i)
  99.                  (vector-ref guess-tm i))))
  100.                (and (not (zero? d)) d)))))
  101.       ((negative? i)
  102.        (let* ((distance (abs (- trough rough))))
  103.          (cond ((and (zero? distance) sign)
  104. ;;;            (print "trying to jump")
  105.             (set! distance (if (negative? sign) -86400 86400)))
  106.            ((and sign (negative? sign)) (set! distance (- distance))))
  107.          (set! guess (offset-time guess distance))
  108. ;;;         (print 'distance distance 'sign sign)
  109.          (cond ((zero? distance) guess)
  110.            ((> j 5) #f)        ;to prevent inf loops.
  111.            (else
  112.             (loop guess
  113.               (+ 1 j)
  114.               (decoder guess))))))))))
  115.  
  116. (define (time:mktime univtime . tz)
  117.   (require 'time-zone)
  118.   (set! tz (if (null? tz) (tzset) (car tz)))
  119.   (+ (gmktime univtime) (tz:std-offset tz)))
  120.  
  121. (define (time:gmktime univtime)
  122.   (time:invert time:gmtime univtime))
  123.  
  124. (define (time:asctime decoded)
  125.   (let ((days   '#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
  126.     (months '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
  127.              "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  128.     (number->2digits
  129.      (lambda (n ch)
  130.        (set! n (number->string n))
  131.        (if (= 1 (string-length n))
  132.            (string-append ch n)
  133.            n))))
  134.     (string-append
  135.      (vector-ref days (vector-ref decoded 6)) " "
  136.      (vector-ref months (vector-ref decoded 4)) " "
  137.      (number->2digits (vector-ref decoded 3) " ") " "
  138.      (number->2digits (vector-ref decoded 2) "0") ":"
  139.      (number->2digits (vector-ref decoded 1) "0") ":"
  140.      (number->2digits (vector-ref decoded 0) "0") " "
  141.      (number->string (+ 1900 (vector-ref decoded 5)))
  142.      (string #\newline))))
  143.  
  144. (define (time:ctime . args)
  145.   (time:asctime (apply time:localtime args)))
  146.  
  147. (define (time:gtime time)
  148.   (time:asctime (time:gmtime time)))
  149.  
  150. ;;;    GMT                Local -- take optional 2nd TZ arg
  151. (define gmtime time:gmtime)    (define localtime time:localtime)
  152. (define gmktime time:gmktime)    (define mktime time:mktime)
  153. (define gtime time:gtime)    (define ctime time:ctime)
  154.  
  155. (define asctime time:asctime)
  156.